;; parse.scm: .thrift format parsing routines for r6rs-thrift
;; Copyright (C) 2012 Julian Graham

;; r6rs-thrift is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

#!r6rs

(library (thrift compile parse)
  (export thriftc:make-parser
	  
	  thriftc:thrift?
	  thriftc:make-thrift
	  thriftc:thrift-includes
	  thriftc:thrift-namespaces
	  thriftc:thrift-definitions
	  
	  thriftc:make-namespace
	  thriftc:namespace
	  thriftc:namespace?
	  thriftc:namespace-name
	  thriftc:namespace-language
	  
	  thriftc:make-const-definition
	  thriftc:const-definition?
	  thriftc:const-definition-type
	  thriftc:const-definition-name
	  thriftc:const-definition-value

	  thriftc:make-typedef-definition
	  thriftc:typedef-definition?
	  thriftc:typedef-definition-source-type
	  thriftc:typedef-definition-destination-type

	  thriftc:make-struct-definition
	  thriftc:struct-definition?
	  thriftc:struct-definition-name
	  thriftc:struct-definition-fields
	  thriftc:struct-definition-exception?
	  thriftc:struct-definition-union?

	  thriftc:make-enum-definition
	  thriftc:enum-definition?
	  thriftc:enum-definition-name
	  thriftc:enum-definition-values
	  thriftc:enum-definition-default
	  
	  thriftc:make-enum-value-definition
	  thriftc:enum-value-definition?
	  thriftc:enum-value-definition-name
	  thriftc:enum-value-definition-ordinal
	  
	  thriftc:make-function-definition
	  thriftc:function-definition?
	  thriftc:function-definition-name
	  thriftc:function-definition-return-type
	  thriftc:function-definition-arguments
	  thriftc:function-definition-throws
	  thriftc:function-definition-oneway?
	  
	  thriftc:make-service-definition
	  thriftc:service-definition?
	  thriftc:service-definition-name
	  thriftc:service-definition-parent
	  thriftc:service-definition-functions

	  thriftc:make-field-definition
	  thriftc:field-definition?
	  thriftc:field-definition-name
	  thriftc:field-definition-ordinal
	  thriftc:field-definition-required?
	  thriftc:field-definition-type)

  (import (rnrs)
 	  (thrift private)
	  (thrift compile conditions)
	  (thrift compile tokenize)
	  (srfi :13)
	  (srfi :14))

  (define (string-split str chr)
    (string-tokenize str (char-set-complement (char-set chr))))

  (define-record-type (thriftc:namespace 
		       thriftc:make-namespace 
		       thriftc:namespace?)
    (fields name language))

  (define-record-type (thriftc:thrift thriftc:make-thrift thriftc:thrift?)
    (fields namespaces includes definitions))

  (define-record-type (thriftc:const-definition
		       thriftc:make-const-definition
		       thriftc:const-definition?)
    (fields name type value))

  (define-record-type (thriftc:function-definition
		       thriftc:make-function-definition
		       thriftc:function-definition?)
    (fields name return-type arguments throws oneway?))

  (define-record-type (thriftc:service-definition
		       thriftc:make-service-definition
		       thriftc:service-definition?)
    (fields name parent functions))

  (define-record-type (thriftc:struct-definition
		       thriftc:make-struct-definition
		       thriftc:struct-definition?)
    (fields name fields exception? union?))

  (define-record-type (thriftc:typedef-definition
		       thriftc:make-typedef-definition
		       thriftc:typedef-definition?)
    (fields source-type destination-type))

  (define-record-type (thriftc:field-definition
		       thriftc:make-field-definition
		       thriftc:field-definition?)
    (fields ordinal required? type name default-value))
 
  (define-record-type (thriftc:enum-value-definition
		       thriftc:make-enum-value-definition
		       thriftc:enum-value-definition?)
    (fields name ordinal))

  (define-record-type (thriftc:enum-definition
		       thriftc:make-enum-definition
		       thriftc:enum-definition?)
    (fields name values default))

  (define (thriftc:make-parser lexer)
    (define unresolved-type-references (list))
    (define unresolved-extensions (list))

    (define resolved-type-descriptors (make-hashtable string-hash equal?))
    (define external-packages (make-hashtable string-hash equal?))

    (define thrift (thriftc:make-thrift))

    (define current-token #f)
    (define current-category #f)
    (define current-value #f)
    
    (define token-stack (list))

    (define (unexpected-token-error)
      (raise (condition 
	      (make-assertion-violation)
	      (make-message-condition 
	       (string-append "Unexpected token: " 
			      (symbol->string current-category)))
	      (thriftc:make-location-condition 
	       (thriftc:lexical-token-source current-token)))))

    (define (get-token) 
      (define (set-data token)
	(set! current-token token)
	(if (eq? token '*eoi*)
	    (begin
	      (set! current-category '*eoi*)
	      (set! current-value '*eoi*))
	    (begin
	      (set! current-category 
		    (thriftc:lexical-token-category current-token))
	      (set! current-value 
		    (thriftc:lexical-token-value current-token)))))
      (if (null? token-stack) 
	  (set-data (lexer))
	  (begin (set-data (car token-stack))
		 (set! token-stack (cdr token-stack)))))
    
    (define (unget-token token)
      (set! current-token #f)
      (set! current-category #f)
      (set! current-value #f)
      
      (set! token-stack (cons token token-stack)))

    (define (assert-next-category category)
      (get-token)
      (if (not (eq? current-category category))
	  (unexpected-token-error)))

    (define (parse-optional-comma-or-semicolon)
      (get-token)
      (if (not (or (eq? current-category 'COMMA)
		   (eq? current-category 'SEMICOLON)))
	  (unget-token current-token)))

    (define (parse-type)
      (get-token)
      (case current-category	
	((BINARY)
	 (thrift:make-type-reference "binary" #f thrift:field-type-binary))
	((BOOL) (thrift:make-type-reference "bool" #f thrift:field-type-bool))
	((BYTE) (thrift:make-type-reference "byte" #f thrift:field-type-byte))
	((I16) (thrift:make-type-reference "i16" #f thrift:field-type-i16))
	((I32) (thrift:make-type-reference "i32" #f thrift:field-type-i32))
	((I64) (thrift:make-type-reference "i64" #f thrift:field-type-i64))
	((DOUBLE) 
	 (thrift:make-type-reference "double" #f thrift:field-type-double))
	((IDENTIFIER) (thrift:make-type-reference current-value #f #f))
	((STRING)
	 (thrift:make-type-reference "string" #f thrift:field-type-string))

	((MAP)
	 (assert-next-category 'LANGLE)
	 (let ((k (parse-type)))
	   (assert-next-category 'COMMA)
	   (let ((v (parse-type)))
	     (assert-next-category 'RANGLE)
	     (thrift:make-complex-type-reference 
	      "map" #f thrift:field-type-map-prototype k v))))
	((LIST) 
	 (assert-next-category 'LANGLE)
	 (let ((v (parse-type)))
	   (assert-next-category 'RANGLE)
	   (thrift:make-complex-type-reference 
	    "list" #f thrift:field-type-list-prototype v)))
	((SET)
	 (assert-next-category 'LANGLE)
	 (let ((v (parse-type)))
	   (assert-next-category 'RANGLE)
	   (thrift:make-complex-type-reference 
	    "set" #f thrift:field-type-set-prototype v)))

	(else (unexpected-token-error))))

    (define (parse-enum)
      (define (parse-enum-fields)
	(define (parse-enum-fields-inner lst)
	  (get-token)
	  (case current-category
	    ((IDENTIFIER) 
	     (let ((field-name current-value))
	       (get-token)
	       (if (eq? current-category 'EQUAL)
		   (begin
		     (assert-next-category 'NUM-INTEGER)
		     (let ((value (thriftc:make-enum-value-definition 
				   field-name current-value)))
		       (parse-optional-comma-or-semicolon)
		       (parse-enum-fields-inner (cons value lst))))
		   (begin
		     (unget-token current-token)
		     (parse-optional-comma-or-semicolon)
		     (parse-enum-fields-inner 
		      (cons (thriftc:make-enum-value-definition field-name #f) 
			    lst))))))
	    ((RBRACE) (reverse lst))
	    (else (unexpected-token-error))))
	
	(parse-enum-fields-inner '()))

      (assert-next-category 'IDENTIFIER)
      (let ((name current-value))
	(assert-next-category 'LBRACE)
	(thriftc:make-enum-definition name (parse-enum-fields) #f)))

    (define (parse-senum)
      (define (parse-senum-fields)
	(define (parse-senum-fields-inner lst ordinal)
	  (get-token)
	  (case current-category
	    ((STRING-LITERAL) 
	     (let ((value (thriftc:make-enum-value-definition 
			   current-value ordinal)))
	       (parse-optional-comma-or-semicolon)
	       (parse-senum-fields-inner (cons value lst) (+ ordinal 1))))
	    ((RBRACE) (reverse lst))
	    (else (unexpected-token-error))))
	
	(parse-senum-fields-inner '() 1))

      (assert-next-category 'IDENTIFIER)
      (let ((name current-value))
	(assert-next-category 'LBRACE)
	(thriftc:make-enum-definition name (parse-senum-fields))))

    (define (parse-const-value)
      (define (parse-const-list)
	(define (parse-const-list-inner lst)
	  (get-token)
	  (if (eq? current-category 'RBRACK)
	      (list->vector (reverse lst))
	      (begin
		(unget-token current-token)
		(let ((v (parse-const-value)))
		  (parse-optional-comma-or-semicolon)
		  (parse-const-list-inner (cons v lst))))))
	(parse-const-list-inner '()))
      
      (define (parse-const-map)
	(define (parse-const-map-inner lst)
	  (get-token)
	  (if (eq? current-category 'RBRACE)
	      (let ((ht (make-eq-hashtable)))
		(for-each (lambda (pair) 
			    (hashtable-set! ht (car pair) (cdr pair)))
			  (reverse lst))
		ht)
	      (begin
		(unget-token current-token)
		(let ((k (parse-const-value)))
		  (assert-next-category 'COLON)
		  (let ((v (parse-const-value)))
		    (parse-optional-comma-or-semicolon)
		    (parse-const-map-inner (cons (cons k v) lst)))))))

	(parse-const-map-inner '()))
      
      (get-token)
      (case current-category
	((NUM-INTEGER NUM-FLOAT STRING-LITERAL IDENTIFIER) current-value)
	((TRUE) #t)
	((FALSE) #f)
	((LBRACK) (parse-const-list))
	((LBRACE) (parse-const-map))
	(else (unexpected-token-error))))

    (define (parse-field)
      (define (parse-field-requiredness ordinal)
	(define (parse-field-type ordinal required?)
	  (define (parse-field-value ordinal required? type name value)
	    (let ((definition (thriftc:make-field-definition 
			       ordinal required? type name value)))
	      (parse-optional-comma-or-semicolon)
	      definition))
	  
	  (let ((type (parse-type)))
	    (assert-next-category 'IDENTIFIER)
	    (let ((name current-value))
	      (get-token)
	      (if (eq? current-category 'EQUAL)
		  (parse-field-value 
		   ordinal required? type name (parse-const-value))
		  (begin (unget-token current-token)
			 (parse-field-value 
			  ordinal required? type name #f))))))

	(get-token)
	(case current-category
	  ((OPTIONAL) (parse-field-type ordinal #f))
	  ((REQUIRED) (parse-field-type ordinal #t))
	  (else (begin 
		  (unget-token current-token) 
		  (parse-field-type ordinal #f)))))

      (get-token)
      (if (eq? current-category 'NUM-INTEGER)
	  (let ((ordinal current-value))
	    (assert-next-category 'COLON)
	    (parse-field-requiredness ordinal))
	  (begin 
	    (unget-token current-token)
	    (parse-field-requiredness #f))))
    
    (define (parse-field-list)
      (define (parse-field-list-inner lst)
	(get-token)
	(if (eq? current-category 'RBRACE)
	    (reverse lst)
	    (begin
	      (unget-token current-token)
	      (parse-field-list-inner (cons (parse-field) lst)))))

      (parse-field-list-inner '()))
    
    (define (parse-struct)
      (assert-next-category 'IDENTIFIER)
      (let ((name current-value))
	(assert-next-category 'LBRACE)
	(thriftc:make-struct-definition name (parse-field-list) #f #f)))

    (define (parse-union)
      (assert-next-category 'IDENTIFIER)
      (let ((name current-value))
	(assert-next-category 'LBRACE)
	(thriftc:make-struct-definition name (parse-field-list) #f #t)))

    (define (parse-exception)
      (assert-next-category 'IDENTIFIER)
      (let ((name current-value))
	(assert-next-category 'LBRACE)
	(thriftc:make-struct-definition name (parse-field-list) #t #f)))

    (define (parse-service)
      (define (parse-function-list)
	(define (parse-function-list-inner lst)
	  (define (parse-function oneway)
	    (define (parse-function-type)
	      (get-token)
	      (if (eq? current-category 'VOID)
		  (thrift:make-type-reference "void" #f thrift:field-type-void)
		  (begin (unget-token current-token)
			 (parse-type))))

	    (define (parse-arg-list)
	      (define (parse-arg-list-inner lst)
		(get-token)
		(if (eq? current-category 'RPAREN)
		    (reverse lst)
		    (begin
		      (unget-token current-token)
		      (parse-arg-list-inner (cons (parse-field) lst)))))
	      (parse-arg-list-inner '()))

	    (define (parse-throw-list)
	      (define (parse-throw-list-inner lst)
		(get-token)
		(if (eq? current-category 'RPAREN)
		    (reverse lst)
		    (begin
		      (unget-token current-token)
		      (let ((field (parse-field)))
			(parse-throw-list-inner 
			 (cons (thriftc:field-definition-type field) lst))))))
	      (parse-throw-list-inner '()))

	    (let ((type (parse-function-type)))
	      (assert-next-category 'IDENTIFIER)
	      (let ((name current-value))
		(assert-next-category 'LPAREN)
		(let* ((args (parse-arg-list))
		       (throws (begin
				 (get-token)
				 (if (eq? current-category 'THROWS)
				     (begin
				       (assert-next-category 'LPAREN)
				       (parse-throw-list))
				     (begin 
				       (unget-token current-token) 
				       '())))))
		  (parse-optional-comma-or-semicolon)
		  (thriftc:make-function-definition
		   name type args throws oneway)))))

	  (get-token)
	  (case current-category
	    ((ONEWAY) 
	     (parse-function-list-inner (cons (parse-function #t) lst)))
	    ((RBRACE) (reverse lst))
	    (else (unget-token current-token)
		  (parse-function-list-inner 
		   (cons (parse-function #f) lst)))))

	(parse-function-list-inner '()))

      (assert-next-category 'IDENTIFIER)
      (let ((name current-value))
	(get-token)
	(let ((parent 
	       (begin (if (eq? current-category 'EXTENDS)
			  current-value
			  (begin (unget-token current-token) #f)))))
	  (assert-next-category 'LBRACE)
	  (thriftc:make-service-definition 
	   name parent (parse-function-list)))))
    
    (define (parse-thrift)
      (define (parse-headers)
	(define (parse-headers-inner namespaces includes)
	  (define (parse-namespace)
	    (get-token)
	    (let ((language (case current-category
			      ((STAR) #f)
			      ((IDENTIFIER) current-value)
			      (else (unexpected-token-error)))))
	      (assert-next-category 'IDENTIFIER)
	      (thriftc:make-namespace language current-value)))
	  
	  (get-token)
	  (case current-category
	    ((INCLUDE)
	     (assert-next-category 'STRING-LITERAL)
	     (parse-headers-inner namespaces (cons current-value includes)))
	    ((NAMESPACE)
	     (parse-headers-inner 
	      (cons (parse-namespace) namespaces) includes))
	    (else (unget-token current-token) 
		  (values (reverse namespaces) (reverse includes)))))

	(parse-headers-inner '() '()))
      
      (define (parse-definitions)
	(define (parse-definitions-inner lst)
	  (define (parse-const)
	    (let ((type (parse-type)))
	      (assert-next-category 'IDENTIFIER)
	      (let ((name current-value))
		(assert-next-category 'EQUAL)
		(let ((value (parse-const-value)))
		  (parse-optional-comma-or-semicolon)
		  (thriftc:make-const-definition name type value)))))

	  (define (parse-typedef)
	    (let ((type (parse-type)))
	      (assert-next-category 'IDENTIFIER)
	      (thriftc:make-typedef-definition type current-value)))
	  
	  (get-token)
	  (case current-category
	    ((CONST) (parse-definitions-inner (cons (parse-const) lst)))
	    ((TYPEDEF) (parse-definitions-inner (cons (parse-typedef) lst)))
	    ((ENUM) (parse-definitions-inner (cons (parse-enum) lst)))
	    ((SENUM) (parse-definitions-inner (cons (parse-senum) lst)))
	    ((STRUCT) (parse-definitions-inner(cons (parse-struct) lst)))
	    ((EXCEPTION) 
	     (parse-definitions-inner (cons (parse-exception) lst)))
	    ((SERVICE) (parse-definitions-inner (cons (parse-service) lst)))
	    ((*eoi*) (reverse lst))
	    (else (unexpected-token-error))))

	(parse-definitions-inner '()))

      (let-values (((namespaces includes) (parse-headers)))
	(thriftc:make-thrift namespaces includes (parse-definitions))))
      
    (lambda () (parse-thrift)))
)
